perm filename DPYIT.F4[PUR,LCS] blob sn#334988 filedate 1979-07-23 generic text, type C, neo UTF8
COMMENT āŠ—   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	C**** SUBRS LINES, RDRAW, UNPACK, GRIDS, SHIFT, SHIFTX, REPACK
C00009 ENDMK
CāŠ—;
C**** SUBRS LINES, RDRAW, UNPACK, GRIDS, SHIFT, SHIFTX, REPACK
	SUBROUTINE LINES(A,B,L)
	COMMON /RZ/RSZ,IPLT,RJB,CENTR
	COMMON /FL/C,D,NQ,RZ,IXRX,XGP,RXGP
	DATA XGP/1200.0/,RX/1.0/
	COMMON/MN/M,N
C  SET XGP TO 1245.0 FOR MARGIN IN XEROX COPIES
23	IF(IPLT)GO TO 2
	M=A*RSZ
	N=B*RSZ
	IF(L.EQ.3)GO TO 1

	IF(IABS(M).GT.600.OR.IABS(N).GT.600)RETURN
C DON'T DISPLAY LINES TOO FAR OFF SCREEN. THEY CAUSE CONFUSION.

	CALL AVECT(M,N)
	RETURN
1	CALL AIVECT(M,N)
	RETURN
CC	DIS=RSZ*1.7
CC	RHT=RSZ*1.7
2	IF(IXRX.EQ.0)GO TO 9
CC	M=-B*RHT-BX+RXGP
	AX=-B*RSZ
	BX=RX*A*RSZ+XGP
CC	N=RX*A*DIS+XGP+AX
	GO TO 8
9	AX=A*RSZ
	BX=B*RSZ
CC9	M=A*DIS+AX
CC	N=B*RHT+BX
8	X=.5
	IF(AX)X=-X
	Y=.5
	IF(BX)Y=-Y
C  A AND B ARE FOR ROUND-OFF
	M=AX+X	
	N=BX+Y
	CALL PLOT(M,N,L)
	END

	SUBROUTINE RDRAW(I,JJ,IJ)
C   TO X,Y INTO ONE WORD
	DIMENSION IJ(1)
	COMMON /RZ/RSZ,IPLT,RJB,CENTR
	COMMON/LL/L
	COMMON/ZN/SCLEF(400,2),DDD
	COMMON/MN/M,N
	DO 2 K=I,JJ
	CALL UNPACK(K,IA,IB,IJ)
	A=IA+RJB
	B=IB+CENTR
	IF(K.EQ.I)GO TO 3
	IF(L.LT.100000000)GO TO 1
3	L=3
1	CALL LINES(A,B,L)
	SCLEF(K,1)=M
2	SCLEF(K,2)=N
	END

	SUBROUTINE UNPACK(K,M,N,I)
	COMMON/LL/L
C  L IS FOR VIS. OR INVIS. LINES.
	DIMENSION I(1)
	N=I(K)
	L=0
	IF(N.LT.100000000)GO TO 2
	L=(N/100000000)*100000000
	N=N-L
2	M=N/10000
	N=N-M*10000
	IF(M.GT.1000)M=1000-M
	IF(N.GT.1000)N=1000-N
	END

	SUBROUTINE GRIDS
	COMMON/RC/MCLEF(400),IST(4000)
	COMMON /RZ/RSZ,IPLT,RJB,CENTR
	EQUIVALENCE(GRID,IST(4000))
	DIMENSION LWRCS(9),IUPCS(8)
	DATA LWRCS/9,110281028,10280045,210045,211028,10281028
	1,210280017, 10030017,10031028/
	1,IUPCS/8,110281028,10280045,370045,371028,10281028
	1, 100041028, 40045/
	CALL POG2
	IF(GRID)GO TO 1
	IF(GRID.EQ.1)GO TO 2
	IF(GRID.EQ.3)GO TO 3
C  NEXT IS UPPER CASE BOX -- GRID=2
	CALL RDRAW(2,IUPCS(1),IUPCS,RJB,CENTR)
	GO TO 1
3	CALL RDRAW(2,LWRCS(1),LWRCS,RJB,CENTR)
C  LOWER CASE BOX
	GO TO 1
2	RB=32
	RC=35.*9./RSZ
	RD=78.*9./RSZ
	RA=2
CC	IF(IPLT.LT.-1)GO TO 333
C  TO SKIP LINES
	DO 30 L=-34,78,4
	RZ=L
	RE=RZ+CENTR
	IF(L.EQ.-2)GO TO 4
	IF(L.EQ.18)GO TO 4
	IF(L.EQ.38)GO TO 4
	IF(L.NE.58)GO TO 32
4	RF=RE+1
	RG=RE+3
	CALL LINES(RJB-1.0,RG,3)
	CALL LINES(RJB+1.0,RF,2)
	CALL LINES(RJB+19.0,RG,3)
	CALL LINES(RJB+21.0,RF,2)
32	XA=2
	XB=0
	IF(L.EQ.14)GO TO 6
	IF(L.NE.42)GO TO 5
6	XA=20
5	IF(L.EQ.-2)GO TO 8
	IF(L.EQ.26)GO TO 8
	IF(L.NE.54)GO TO 7
8	XB=20
7	CALL LINES(RJB-RA-XA,RE,3)
	CALL LINES(RJB+RB+XA,RE,2)
	CALL LINES(RJB+RB+XB,RE+2.0,3)
30	CALL LINES(RJB-RA-XB,RE+2.0,2)
	DO 31 L=-2,32,4
	RZ=L
	RE=RZ+RJB
	CALL LINES(RE,CENTR-RC,3)
	CALL LINES(RE,CENTR+RD,2)
	CALL LINES(RE+2.0,CENTR+RD,3)
31	CALL LINES(RE+2.0,CENTR-RC,2)
	CALL LINES(RJB-10.,CENTR-14.,3)
	CALL LINES(RJB,CENTR-14.,2)
	CALL LINES(RJB,CENTR-28.,3)
	CALL LINES(RJB-10.,CENTR-28.,2)
1	CALL DPYOUT(2)
	CALL POG1
	END

	SUBROUTINE SHIFT(M,L,NN)
	DIMENSION M(1)
	COMMON/RC/MCLEF(400),IST(4000)
	EQUIVALENCE (KK,IST(2))
	IF(NN.EQ.'M')GO TO 5
	TYPE 7
	GO TO 6
5	TYPE 1
6	KK=2
	ACCEPT 2,H,V,SH,SV
	IF(SH.EQ.0)SH=1
	IF(SV.EQ.0)SV=1
1	FORMAT(' MOVE HORIZ, VERT., SIZE H, SIZE V'/)
2	FORMAT(4F)
7	FORMAT(' TYPE DEGREES -- '$)
CC	IF(L.GT.0)GO TO 10
CC	L=-L
CC	V=999.
10	DO 3 K=1,L-1
	CALL UNPACK(K,J,N,M)
CC	IF(V.NE.999)GO TO 4
	IF(NN.EQ.'M')GO TO 4
C   ROTATION      DEGREES.
	X=J
	Y=N
	AX=ATAN2(Y,X)*57.2957768
	HYP=SQRT(X**2+Y**2)
	ROT=AX-H
C  -H, SO ROTATION IS CLOCKWISE INSTEAD OF CNTRCLKWS.
C  H=DEGREES
	X=HYP*COSD(ROT)
	Y=HYP*SIND(ROT)
	AX=.5
	IF(X)AX=-AX
C  AX IS FOR ROUND-OFF
	J=X+AX
	AX=.5
	IF(Y)AX=-AX
	N=Y+AX
	GO TO 3

4	J=H+J*SH
	N=V+N*SV
3	CALL REPACK(K,J,N,M)
	END

	SUBROUTINE REPACK(K,M,N,I)
	COMMON/LL/L
	DIMENSION I(1)
	M=M*10000
	IF(M)M=10000000-M
	IF(N)N=1000-N
	M=M+L
	I(K)=M+N
	END

	SUBROUTINE BUP
	COMMON/RC/MCLEF(400),IST(4000)
	IST(2)=IST(2)-1
	CALL HYDPOG(1)
	CALL ACCPOG(1)
	END

	SUBROUTINE POG2
	COMMON /RC/MCLEF(3400),IST(1000)
	CALL DPYSET(2,IST,200)
	CALL DPYBRT(2)
	END

	SUBROUTINE POG1
	CALL HYDPOG(3)
	CALL SETPOG(1)
	CALL DPYBRT(4)
	END